home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / utils / tree-menu.el < prev    next >
Encoding:
Text File  |  1995-05-23  |  6.2 KB  |  199 lines
  1. ;;; tree-menu.el
  2. ;;; v1.20; 10-May-1994
  3. ;;; Copyright (C) 1994 Heiko Muenkel
  4. ;;; email: muenkel@tnt.uni-hannover.de
  5. ;;;
  6. ;;;  This program is free software; you can redistribute it and/or modify
  7. ;;;  it under the terms of the GNU General Public License as published by
  8. ;;;  the Free Software Foundation; either version 1, or (at your option)
  9. ;;;  any later version.
  10. ;;;
  11. ;;;  This program is distributed in the hope that it will be useful,
  12. ;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;;  GNU General Public License for more details.
  15. ;;;
  16. ;;;  You should have received a copy of the GNU General Public License
  17. ;;;  along with this program; if not, write to the Free Software
  18. ;;;  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19. ;;;
  20. ;;; 
  21. ;;; Description:
  22. ;;;
  23. ;;;    Provides the functions `tree-make-file-list' and `tree-make-menu'.
  24. ;;;    With these functions it is possible to generate file browsing menus,
  25. ;;;     where each menu-item calls the same function, but on different files.
  26. ;;;    Example: 
  27. ;;;         (popup-menu (cons "Open File"
  28. ;;;                        (tree-make-menu (tree-make-file-list "~/")
  29. ;;;                            'find-file
  30. ;;;                            t
  31. ;;;                            t
  32. ;;;                            '("\\..*"))))
  33. ;;;
  34. ;;;    Note: This function is very time consuming ! Therefore you should
  35. ;;;          call `tree-make-file-list' once and make several menus
  36. ;;;          from the same list. And you should only rebuild the menu if 
  37. ;;;          it is neccessary, if you've a big directory tree.
  38. ;;;
  39. ;;; Installation: 
  40. ;;;   
  41. ;;;    Put this file in one of your lisp load directories.
  42. ;;;
  43. ;;;  Changed 18-May-1995, Kyle Jones
  44. ;;;    Removed the need for the utils.el package and references thereto.
  45. ;;;    Changed file-truename calls to tree-menu-file-truename so
  46. ;;;    the calls could be made compatible with FSF Emacs 19's
  47. ;;;    file-truename function.
  48.  
  49. (defvar tree-ls-flags "-AFLR" 
  50.   "*A String with the flags used in the function tree-ls-in-temp-buffer 
  51. for the ls command. Be careful if you want to change this variable. 
  52. The ls command must append a / on all files which are directories. 
  53. The original flags are -AFLR.")
  54.  
  55.  
  56. (defun tree-ls-in-temp-buffer (dir temp-buffer)
  57. "List the directory DIR in the TEMP-BUFFER."
  58.   (switch-to-buffer temp-buffer)
  59.   (erase-buffer)
  60.   (call-process "ls" nil temp-buffer nil tree-ls-flags dir)
  61.   (goto-char (point-min))
  62.   (while (search-forward "//" nil t)
  63.     (replace-match "/"))
  64.   (goto-char (point-min)))
  65.  
  66.  
  67. (defvar tree-temp-buffername "*tree*"
  68.   "Name of the temp buffers in tree.")
  69.  
  70.  
  71. (defun tree-make-file-list-1 (root list)
  72.   (let ((filename (buffer-substring (point) (progn
  73.                           (end-of-line)
  74.                           (point)))))
  75.     (while (not (string= filename ""))
  76.       (setq 
  77.        list 
  78.        (append
  79.     list
  80.     (list
  81.      (cond ((char-equal (char-after (- (point) 1)) ?/)
  82.         ;; Directory
  83.         (setq filename (substring filename 0 (1- (length filename))))
  84.         (save-excursion
  85.           (search-forward (concat root filename ":"))
  86.           (forward-line)
  87.           (tree-make-file-list-1 (concat root filename "/")
  88.                         (list (tree-menu-file-truename 
  89.                                filename
  90.                                root)))))
  91.            ((char-equal (char-after (- (point) 1)) ?*)
  92.         ;; Executable
  93.         (setq filename (substring filename 0 (1- (length filename))))
  94.         (tree-menu-file-truename filename root))
  95.            (t (tree-menu-file-truename filename root))))))
  96.       (forward-line)
  97.       (setq filename (buffer-substring (point) (progn
  98.                          (end-of-line)
  99.                          (point)))))
  100.     list))
  101.  
  102.  
  103. (defun tree-menu-file-truename (file &optional root)
  104.   (file-truename (expand-file-name file root)))
  105.  
  106. (defun tree-make-file-list (dir)
  107.   "Makes a list with the files and subdirectories of DIR.
  108. The list looks like: ((dirname1 file1 file2) 
  109.                       file3
  110.                       (dirname2 (dirname3 file4 file5) file6))"
  111.   (save-window-excursion
  112.     (setq dir (expand-file-name dir))
  113.     (if (not (string= (substring dir -1) "/"))
  114.     (setq dir (concat dir "/")))
  115. ;;    (while (string-match "/$" dir)
  116. ;;      (setq dir (substring dir 0 -1)))
  117.     (tree-ls-in-temp-buffer dir
  118.                  (generate-new-buffer-name 
  119.                   tree-temp-buffername))
  120.     (let ((list nil))
  121.       (setq list (tree-make-file-list-1 dir nil))
  122.       (kill-buffer (current-buffer))
  123.       list)))
  124.  
  125.  
  126. (defun tree-hide-file-p (filename re-hidden-file-list)
  127.   "t, if one of the regexps in RE-HIDDEN-FILE-LIST matches the FILENAME."
  128.   (cond ((not re-hidden-file-list) nil)
  129.     ((string-match (car re-hidden-file-list) 
  130.                (tree-menu-file-truename filename)))
  131.     (t (tree-hide-file-p filename (cdr re-hidden-file-list)))))
  132.  
  133.  
  134. (defun tree-make-menu (dirlist 
  135.                function 
  136.                selectable 
  137.                &optional 
  138.                no-hidden-dirs
  139.                re-hidden-file-list
  140.                include-current-dir)
  141.   "Returns a menu list.
  142. Each item of the menu list has the form 
  143.  [\"subdir\" (FUNCTION \"dir\") SELECTABLE].
  144. Hidden directories (with a leading point) are suppressed, 
  145. if NO-HIDDEN-DIRS are non nil. Also all files which are
  146. matching a regexp in RE-HIDDEN-FILE-LIST are suppressed.
  147. If INCLUDE-CURRENT-DIR non nil, then an additional command
  148. for the current directory (.) is inserted."
  149.   (let ((subdir nil)
  150.     (menulist nil))
  151.     (while (setq subdir (car dirlist))
  152.       (setq dirlist (cdr dirlist))
  153.       (cond ((and (stringp subdir)
  154.           (not (tree-hide-file-p subdir re-hidden-file-list)))
  155.          (setq menulist
  156.            (append menulist
  157.                (list
  158.                 (vector (file-name-nondirectory subdir)
  159.                     (list function subdir)
  160.                     selectable)))))
  161.         ((and (listp subdir)
  162.           (or (not no-hidden-dirs)
  163.               (not (char-equal 
  164.                 ?.
  165.                 (string-to-char 
  166.                  (file-name-nondirectory (car subdir))))))
  167.           (setq menulist
  168.             (append 
  169.              menulist
  170.              (list
  171.               (cons (file-name-nondirectory (car subdir))
  172.                 (if include-current-dir
  173.                     (cons
  174.                      (vector "."
  175.                          (list function
  176.                            (car subdir))
  177.                          selectable)
  178.                      (tree-make-menu (cdr subdir)
  179.                              function
  180.                              selectable
  181.                              no-hidden-dirs
  182.                              re-hidden-file-list
  183.                              include-current-dir
  184.                              ))
  185.                   (tree-make-menu (cdr subdir)
  186.                           function
  187.                           selectable
  188.                           no-hidden-dirs
  189.                           re-hidden-file-list
  190.                           ))))))))
  191.         (t nil))
  192.       )
  193.     menulist
  194.     )
  195.   )
  196.  
  197.  
  198. (provide 'tree-menu)
  199.